home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Environments / AllegroCL11 / Library / Fred-Extensions.Lisp < prev    next >
Encoding:
Text File  |  1987-10-27  |  7.5 KB  |  202 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;Fred-Extensions.Lisp
  4. ;;
  5. ;;copyright © 1987, Coral Software Corp
  6. ;;
  7. ;;this file contains extensions to Fred the editor.
  8. ;;
  9. ;;it can also be used as a source of examples for Fred programming.
  10.  
  11.  
  12.  
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15. ;;ed-block-selection
  16. ;;
  17. ;;  This function is used for re-blocking paragraphs of text.
  18. ;;  It doesn't work on code (because it erases pretty printing)
  19. ;;  and it doesn't work on comments (because semi-colons might be moved
  20. ;;  away from the beginning of a line).  It's basically good when Fred is
  21. ;;  being used to edit straight text files.
  22. ;;
  23. ;;  The function first deletes carriage-returns from the selection, and then
  24. ;;  re-inserts them to make all the lines the same length.  If there are
  25. ;;  two or more carriage-returns in a row, it takes them as a paragraph break
  26. ;;  and leaves them in place.
  27. ;;
  28. ;;  The line length is determined by the variable *fred-max-line-width*
  29. ;;
  30. ;;
  31.  
  32.  
  33. ;;bind the blocking command to meta-space
  34. (def-fred-command
  35.   (:meta #\q)
  36.   ed-block-selection)
  37.  
  38. ;;define the special variable which holds the line length
  39. (defvar *fred-max-line-width* 80)
  40.  
  41. (defobfun (ed-block-selection *fred-window*) (&aux (buf (window-buffer))
  42.                                                    next-char
  43.                                                    prev-char
  44.                                                    new-start
  45.                                                    next-break
  46.                                                    next-line)
  47.   (multiple-value-bind (b e)
  48.                        (selection-range)
  49.     
  50.     (unless (eq b e)
  51.       (setq b (make-mark buf (buffer-line-start buf b))
  52.             e (make-mark buf (buffer-line-end buf e) t)   ;a backward mark
  53.             new-start (mark-position b))
  54.       (buffer-insert buf (format nil "~%  ") e)
  55.       (loop
  56.         (setq new-start (buffer-line-end buf new-start))
  57.         (when (>= new-start (mark-position e)) (return))
  58.         (setq next-char  (buffer-char buf (+ new-start 1))
  59.               prev-char (or (eq new-start 0) (buffer-char buf (- new-start 1))))
  60.         (unless (or (eq next-char #\return) (eq prev-char #\return))
  61.           (if (or (eq next-char #\space) (eq prev-char #\space))
  62.             (buffer-delete buf :start new-start :length 1)
  63.             (buffer-char-replace buf #\space new-start)))
  64.           (setq new-start (min (+ new-start 1) (buffer-size buf))))
  65.       (setq new-start (mark-position b))
  66.       (loop
  67.         (when (or (>= new-start (buffer-size buf))
  68.                   (and next-break
  69.                        (>= next-break (mark-position e))))
  70.           (return))
  71.         (loop
  72.           (setq next-line (buffer-line-end buf new-start)
  73.                 next-break (+ new-start *fred-max-line-width*))
  74.           (if (<= next-line next-break)
  75.               (setq new-start (+ next-line 1))
  76.               (return)))
  77.         (setq next-break (buffer-char-pos buf #\space
  78.                                           :start new-start
  79.                                           :end next-break
  80.                                           :from-end t))
  81.         (when next-break
  82.           (buffer-char-replace buf #\return next-break)
  83.           (setq new-start (+ next-break 1)))
  84.         (setq next-break (min (+ new-start *fred-max-line-width*)
  85.                          (buffer-size buf))))
  86.       (buffer-delete buf :start e :length 3)
  87.       (kill-mark e)
  88.       (kill-mark b))))
  89.  
  90.  
  91. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93. ;;ed-delete-forward-whitespace
  94. ;;
  95. ;;  deletes all the whitespace from the cursor to the next non-whitespace
  96. ;;  character.  If there is a selection, the selection is also deleted.
  97. ;;
  98.  
  99. ;;define the function
  100. (defobfun (ed-delete-forward-whitespace *fred-window*) ()
  101.   (multiple-value-bind (b e) (selection-range)
  102.     (if (/= b e) (clear)               ;If there is a selection, just kill it.
  103.         (let ((buffer (window-buffer)))
  104.           (buffer-delete buffer :start b
  105.                                 :end (or (buffer-not-char-pos buffer "
  106.       " :start b)
  107.                                          (buffer-size buffer)))))))
  108. ;;bind it to a keystroke in the control-x comtab.
  109. ;;  this means that you invoke the command by typing control-x control-space
  110. (comtab-set-key *control-x-comtab*
  111.                 '(:control #\space)
  112.                 'ed-delete-forward-whitespace)
  113.  
  114.  
  115. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  116. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  117. ;;ed-other-window
  118. ;;
  119. ;;  toggles between the top two fred windows.
  120. ;;  (the listener counts as a fred window.)
  121. ;;
  122.  
  123. ;;define the function
  124. (defobfun (ed-other-window *fred-window*) ()
  125.   (let ((windows (cdr (windows *fred-window*))))
  126.     (if windows
  127.       (ask (car windows) (window-select))
  128.       (ed-beep))))
  129.  
  130. ;;set it to a keystroke in the control-x comtab.
  131. ;;  this means you type control-x, followed by o (without control) to invoke
  132. ;;  the command
  133. (comtab-set-key *control-x-comtab*
  134.                 #\o
  135.                 'ed-other-window)
  136.  
  137.  
  138. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  139. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  140. ;;ed-move-to-comment
  141. ;;
  142. ;;  moves to a specified column after the end of a line and inserts a
  143. ;;  semi-colon in preparation for inserting comments
  144. ;;
  145. ;;  If there is already a semi-colon in the line, it just positions the
  146. ;;  cursor after the semi-colon.
  147. ;;
  148.  
  149. ;column where comments will be inserted
  150. (defvar *comment-default-column* 45)
  151.  
  152. ;used for formatting
  153. (defvar *string-of-70-spaces*
  154.   "                                                                      ")
  155.  
  156. ;;the function itself
  157. (defobfun (ed-move-to-comment *fred-window*) ()
  158.   (let* ((curs (window-cursor-mark))
  159.          (buf (window-buffer))
  160.          (line-b (buffer-line-start buf curs))
  161.          (line-e (buffer-line-end buf curs))
  162.          (last-semi (buffer-char-pos buf #\;
  163.                                      :start line-b
  164.                                      :end line-e
  165.                                      :from-end t)))
  166.     (if last-semi
  167.         (set-mark curs (+ last-semi 1))
  168.         (progn
  169.           (when (> (buffer-column buf line-e)
  170.                    *comment-default-column*)
  171.             (buffer-insert buf #\return line-e)
  172.             (incf line-e))
  173.           (buffer-insert buf
  174.                          (subseq *string-of-70-spaces*
  175.                                  0
  176.                                  (- *comment-default-column*
  177.                                     (buffer-column buf line-e)))
  178.                          line-e)
  179.           (setq line-e (buffer-line-end buf line-e))
  180.           (buffer-insert buf #\; line-e)
  181.           (set-mark curs (+ line-e 1))))))
  182.  
  183. ;;define a fred command for calling the function
  184. (def-fred-command (:meta #\;) ed-move-to-comment)
  185.  
  186.  
  187. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  188. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  189. ;;
  190. ;;  redefine two keystrokes, so that control forward-arrow and back-arrow
  191. ;;  can be used for moving forward and backward by Lisp expression.
  192.  
  193.  
  194. (def-fred-command (:control #\backarrow)
  195.                   ccl::ed-backward-sexp)
  196.  
  197. (def-fred-command (:control #\forwardarrow)
  198.                   ccl::ed-forward-sexp)
  199.  
  200.  
  201. (provide 'fred-extensions)
  202. (pushnew :fred-extensions *features*)